Pascal Super Library/Pascal Super Library (CW International)(1997).bin/MLT_TASK/ONCE/ONCE.PAS

Pascal/Delphi Source File | 1995-02-12 | 19KB | 560 lines

{************************************************}
{                                                }
{                                                }
{   Copyright(c) by Alan Pozner 1995 all rights  }
{                reserved                        }
{                                                }
{                                                }
{         TITLE : ONCE.PAS                       }
{   CREATE DATE : 1/24/95                        }
{                                                }
{        AUTHOR : Alan Pozner                    }
{                                                }
{                                                }
{                                                }
{      LANGUAGE : Turbo Pascal foe Windows 1.5   }
{      COMPILER : Borland Turbo Pascal 1.5 for   }
{                 Windows                        }
{     CALLED BY : none                           }
{                                                }
{                                                }
{         CALLS : wobjects, winprocs, wintypes,  }
{                        windos, strings, win31,shellapi}
{                 toolhelp                       }
{                                                }
{       PURPOSE : Source code for ONCE.EXE       }
{                 A Windows wrapper program that }
{                 allows only one instance of    }
{                 another application to be run  }
{                 concurrently.                  }
{                                                }
{        USEAGE : A Windows INI file for the     }
{                 program to be protected must be}
{                 created before using ONCE. Then}
{                 the name of the ini file is    }
{                 entered as a command line param}
{                 eter.  i.e. for an ini file    }
{                 named DOS.INI the command line }
{                 should read ONCE DOS.INI       }
{                                                }
{                 The format of the ini file is  }
{    [PARAMETERS]                                  }
{  AppFileName=file name of app to run           }
{               - including path                 }
{  AppTitle= the name to appear on the Title bar*}
{  WorkingDir=path for working directory*        }
{  IconFile=file name and path of icon file*     }
{  IconNumber=index of icon in icon file 0=first*}
{                                                }
{* the last four parameters are only required for}
{      DOS apps.                                 }
{  Windows apps ignore them.                     }
{                                                }
{   LAST UPDATE : 2/12/95                        }
{                                                }
{************************************************}


program Once;



uses wobjects, winprocs, wintypes, windos, strings, shellapi,win31,toolhelp;{standard TPW units}


{************************************************}
{       Global Constants                         }
{************************************************}

const
    ini_name           = 'ONCE.INI';    {INI file name}

                                                        {these 2 are for the ini file}
    protected          = 'ProtectedApps';
    filename           = 'FileName';
    instancehandle     = 'InstanceHandle';

                                          {messagebox Messages}
    guide1             = 'OneTime is a program launcher which allows only one instance.';
    guide2             = 'OneTime    Copyright ⌐ 1995 by Alan Pozner';
    guide3             = 'Please read the README.TXT file that accompanies this program for useage';
    loadfail           = 'Loading Failed. Check parameters and filenames';




{************************************************}
{       Global Variables                         }
{************************************************}

var
    szAppFileName,
    szAppTitle,
    szWorkingDir,
   szIconFile,
    szIniPath,
    szIniName : array[0..79] of char;
    wIconnumber   : word;
    ProtectedTask,
    ProtectedInstance : THandle;



type
{************************************************}
{       application object type def              }
{************************************************}
OneTimeApp = object(TApplication)
    procedure initmainwindow; virtual;
end;   {OneTimeApp type def




{************************************************}
{       main window object type def              }
{************************************************}
pOneTimeWindow = ^TOneTimeWindow;
TOneTimeWindow = object(Twindow)
    DDEDone   : boolean;
    constructor init(AParent: PWindowsObject; ATitle: pchar);
    destructor Done; virtual;
    function GetClassName:pchar;virtual;
    procedure SetUpWindow; virtual;
    procedure WMSize(var Msg : TMessage);
        virtual wm_First + wm_size;
    procedure WMTimer(var Msg: TMessage);
      virtual wm_First + wm_timer;
    procedure WMDDEInitiate(var Msg: TMessage);
        virtual wm_First + wm_DDE_Initiate;
    procedure WMDDERequest(var Msg: TMessage);
        virtual wm_First + wm_DDE_Request;
end;  {TOneTimeWindow type def}


function GetInstanceTask(theInstance:THandle):THandle;
var
    aTaskEntry : pTaskEntry;
   tempTask   : THandle;
begin
    getmem(aTaskEntry,sizeof(TTaskEntry));
    aTaskEntry^.dwSize := sizeof(TTaskEntry);
    taskfirst(aTaskEntry);
    tempTask := 0;
    if aTaskEntry^.hInst = theInstance then
        tempTask := aTaskEntry^.hTask
    else
        while taskNext(aTaskEntry) and (tempTask = 0) do
            if aTaskEntry^.hInst = theInstance then
                tempTask := aTaskEntry^.hTask;
   GetInstanceTask := tempTask;
    freemem(aTaskEntry,sizeof(TTaskEntry));
end;

function GetTaskWindow(theTask:THandle):hwnd;
var
    gotit      : boolean;
   temphwnd   : hwnd;
begin
    gotit := false;
    temphwnd := GetWindow(gettopwindow(0),GW_HWNDLAST);
    while (temphwnd <> 0) and (not gotit)  do
        if (getwindowtask(temphwnd) = theTask) and iswindowvisible(temphwnd) then
            gotit := true
        else
          temphwnd := GetWindow(temphwnd,GW_HWNDPREV);
    GetTaskWindow := temphwnd;
end;

function GetTheClassName(Wnd: HWnd;      {this function is necessary because}
                    ClassName: PChar;         {of a name collision between }
                    MaxCount: Integer): Integer; {the API function and the object}
begin                                       {method GetClassName}
    GetTheClassName := GetClassName(Wnd, ClassName, MaxCount);
end;    {GetTheClassName}


function DumpIcon(lpInfo, lpLen, XORBits, ANDBits : Pointer) : LongInt; far; EXTERNAL 'USER' Index 459;

function GetIconData(Icon : hIcon) : THandle;
  type
    PCursorIconInfo = ^CursorIconInfo;
    CursorIconInfo = record
     HotSpot : TPoint;
      Width, Height, WidthBytes : Word;
      Planes, BitsPixel : Byte
      end;

    PIconProps = ^TIconProps;
    TIconProps = record
      Flags : Word;
      cfFormat : Integer;
      Width, Height : Integer;
      Planes, BitsPixel : Byte;
      XORbits, ANDbits : Pointer;
    end;

  var
     I : PCursorIconInfo;
     P : PIconProps;
     H : THandle;
     hdrlen : Word;
     pANDBits, pXORBits : Pointer;
     size : Word;
  begin
  I := LockResource(Icon);
  size := HiWord(DumpIcon(I, @HdrLen, @pXORbits, @pANDBits));
  if size <> 0 then
    begin
{the best thing to do here would be to allocate 'size' more bytes here
and copy the data pointed to by pANDBits/pXORBits to the end of the structure,
but this works so I haven't done it yet.}
    H := GlobalAlloc(GMEM_DDESHARE, Sizeof(TIconProps));{ +size);}
    P := GlobalLock(H);
    P^.Width := I^.Width;
    P^.Height := I^.Height;
    P^.Planes := I^.Planes;
    P^.BitsPixel := I^.BitsPixel;
    P^.ANDBits := pANDBits;
    P^.XORBits := pXORBits;
    GlobalUnlock(H);
     UnlockResource(Icon);
    GetIconData := H;
    end
  else
    GetIconData := 0;
  end;
function intostr(buffer: pchar;i:longint) : pchar;
var
      s : string;
begin
      str(i, s);
    strpcopy(buffer,s);
   intostr := buffer;
end;


{************************************************}
{       Method implementation for                }
{     Procedure OneTimeApp.initmainwindow        }
{                                                }
{     This is the entry point to the program     }
{     after initialization overhead and before   }
{     any windows are created.                   }
{                                                }
{     Command line parameters are checked        }
{     If OK then we check for another instance of}
{     ONETIME. If another instance is found      }
{     we check ONETIME.INI to see if the         }
{     protected app is the same. If so display   }
{     a message and quit. Otherwise we move on   }
{     with loading.  If no command line parameter}
{     display guide  message and quit. If        }
{     no other instance of ONETIME is running    }
{     clean out ONETIME.INI This is necessary    }
{     to avoid lockout in the event of previous  }
{     unusual termination i.e. The user shut     }
{     down without exiting windows.              }
{                                                }
{************************************************}
procedure OneTimeApp.initmainwindow;
var
    sztemp,
    WindowsDir : array[0..79] of char;
    oldwindowhandle : hwnd;
    oldTaskHandle,
    oldInstanceHandle : tHandle;
    tempi,
    code :integer;
begin
    GetWindowsDirectory(WindowsDir,79);
    strcat(strcat(strcopy(szIniPath,
                WindowsDir),'\'),ini_name);
    if paramcount > 0 then                   {if there is a command line}
                                                          {    parameter}
    begin
        strpcopy(szIniName,paramstr(1));  {load 1st parameter}

        if HPrevInst = 0 then                 {if this is only ONETIME instance}
        begin
            _lclose(_lcreat(szIniPath,0));            {erase old INI file}
        end;
        GetPrivateProfileString('Parameters','AppFileName',
                                        '',szAppFileName,sizeof(szAppFileName),
                              szIniName);
        GetPrivateProfileString('Parameters','AppTitle',
                                        '',szAppTitle,sizeof(szAppTitle),
                              szIniName);
        GetPrivateProfileString('Parameters','WorkingDir',
                                        '',szWorkingDir,sizeof(szWorkingDir),
                              szIniName);
        GetPrivateProfileString('Parameters','IconFile',
                                        '',szIconFile,sizeof(szIconFile),
                              szIniName);
        wIconNumber := GetPrivateProfileInt('Parameters',
                                    'IconNumber', 0, szIniName);
        if GetPrivateProfileInt(              {if this app is not protected}
                Protected,
                szAppFileName,0,
                szIniPath) = 0 then              {then}
        begin
            WritePrivateProfileString(         {protect it by loading name in INI}
             Protected,szAppFileName,        {file}
                '1',szIniPath);                  {and}
            mainwindow := new(pOneTimeWindow,  {start up main window which will }
                init(nil,'Main Window'));       {load the app and install hooks}
        end
        else                                  {else this app is protected so}
        begin
            GetPrivateProfileString(szAppFileName,InstanceHandle,
                                        '',szTemp,sizeof(szTemp),
                              szIniPath);
            val(sztemp,tempi,code);
            if code = 0 then
            begin
                oldinstancehandle := thandle(tempi);
                oldtaskhandle := GetInstanceTask(oldinstanceHandle);
                oldwindowhandle := GetTaskWindow(oldtaskhandle);
                if iswindow(oldwindowhandle) then
                begin
                    setactivewindow(oldwindowhandle);
                    GetModuleFileName(oldinstancehandle,sztemp,79);
               if strpos(sztemp,'.MOD') = nil then
                        showwindow(oldwindowhandle,SW_SHOW)
                    else
                        showwindow(oldwindowhandle,SW_SHOWNORMAL);
                end;
            end;
            halt;                              {and quit}
        end;                                  {end 'if this app isn't protected'}
    end
    else                                     {else there are no command line }
    begin                                    {parameters}
        messagebeep(0);
        messagebox(0,guide1,guide2,           {so display useage guide}
                mb_ok or mb_systemmodal);
        messagebox(0,guide3,guide2,
                mb_ok or mb_systemmodal);
        halt;                                 {and quit}
    end;                                                  {end 'if there's parameters}

end;          {OneTimeApp.initmainwindow}



constructor TOneTimeWindow.init(AParent: PWindowsObject; ATitle: pchar);
begin
    TWindow.init(AParent,Atitle);
    with Attr do
    begin
        x:= -100;
        y:= -100;
        w:= 10;
        h:= 10;
    end;
end;

{************************************************}
{       Method implementation for                }
{     Procedure TOneTimeWindow.SetUpWindow       }
{                                                }
{     SetUpWindow procedure is called by Windows }
{     immediately after window initialization    }
{                                                }
{     If we get this far it means that the       }
{     protected app is not running.              }
{                                                }
{     We try to set the Hook. If unsuccessful    }
{     give the user a message to contact MIS     }
{                                                }
{     If the hook is set we make a call to       }
{     WINEXEC to start the app. If successful    }
{     protect app by modifying INI file.         }
{     If unsuccessful loading then remove app    }
{     protection from INI file, display an error }
{     message and quit.                          }
{                                                }
{************************************************}
procedure TOneTimeWindow.SetUpWindow;
var
   instancename,
    afilename : array[0..79] of char;
    tempword : word;
begin
   DDEDone := false;
    ProtectedInstance := winexec(             {try to start app}
        szAppFileName,SW_SHOWNORMAL);
    if ProtectedInstance < 32 then            {if starting failed}
    begin
        WritePrivateProfileString(               {unprotect the app by }
            Protected,szAppFileName,           {removing name from INI file}
            nil,szIniPath);                     {and}
        messagebeep(0);
        messagebox(hwindow,                   {display error message}
            LoadFail,szAppFileName, mb_OK or mb_iconexclamation);
        postmessage(hwindow,wm_close,0,0);      {quit this app}
      exit;
    end;                                     {end 'if loadinf failed}
    GetModuleFileName(ProtectedInstance,afilename,79);
    WritePrivateProfileString(
        szAppFileName,FileName,aFileName,szIniPath);
    intostr(instancename,ProtectedInstance);
    WritePrivateProfileString(
        szAppFileName,InstanceHandle,instancename,szIniPath);
    if SetTimer(HWindow, 1, 1000, nil) = 0 then
   begin
        MessageBox(HWindow, 'No Timers Left', 'Error', mb_Ok);
          Halt(1);
      end;
end;      {TOneTimeWindow.SetUpWindow}

procedure TOneTimeWindow.WMSize(var Msg : TMessage);
begin
    Show(sw_hide);                           {hide this window}
    twindow.wmsize(msg);                     {on startup}
end;      {TOneTimeWindow.WMSize}


procedure TOneTimeWindow.WMTimer(var Msg: TMessage);
begin
    if GetInstanceTask(ProtectedInstance)=0 then
    begin
        killtimer(hwindow,1);
        postmessage(hwindow,wm_close,0,0);      {quit this app}
    end;
end;

procedure TOneTimeWindow.WMDDEInitiate(var Msg: TMessage);
var
   szTopic,
    szApp:array[0..127] of char;
begin
    if (not DDEDone) then
    begin
        GlobalGetAtomName(TAtom(LoWord(Msg.Lparam)),szApp,sizeof(szApp)-1);
        GlobalGetAtomName(TAtom(HiWord(Msg.Lparam)),szTopic,sizeof(szTopic)-1);
        if (stricomp(szApp,'shell')=0) and (stricomp(szTopic,'APPPROPERTIES')=0) then
            sendmessage(msg.wparam,WM_DDE_ACK,hwindow,msg.lparam)
        else
          defwndproc(msg)
    end
    else
        defwndproc(msg);
end;

procedure TOneTimeWindow.WMDDERequest(var Msg: TMessage);
const
    fRelease = $4;  {this doesn't seem to work}
var
   szTopic,
    szApp:array[0..127] of char;
    counter : integer;
    AppTopic : TAtom;
    HData : THandle;
    PData : PDDEData;
    DataError : boolean;
    anicon:hicon;
   picon : pointer;
begin
    if (not DDEDone) then
    begin
        AppTopic := TAtom(HiWord(Msg.Lparam));
        GlobalGetAtomName(AppTopic,szTopic,sizeof(szTopic)-1);
        if stricomp(szTopic,'GetDescription') = 0 then
        begin
            HData := GlobalAlloc(gmem_Moveable or gmem_DDEShare,
                            sizeof(TDDEData) + strlen(szAppTitle) +1);
            if HData <> 0 then
            begin
                PData := GlobalLock(HData);
                if PData = nil then
                begin
                    GlobalFree(HData);
                    DataError := true;
                end
                else
                begin
                    PData^.Flags := dde_release;
                    PData^.CFFormat := cf_text;
                    strlcopy(PData^.Value, szAppTitle, strlen(szAppTitle)+1);
                    GlobalUnlock(HData)
                end;
            end;
            if not PostMessage(Msg.WParam, wm_DDE_Data, hwindow,
                                        makelong(HData,AppTopic)) then
                GlobalFree(HData);
        end
        else
            if stricomp(szTopic,'GetWorkingDir') = 0 then
            begin
                HData := GlobalAlloc(gmem_Moveable or gmem_DDEShare,
                                sizeof(TDDEData) + strlen(szWorkingDir) +1);
                if HData <> 0 then
                begin
                    PData := GlobalLock(HData);
                    if PData = nil then
                    begin
                        GlobalFree(HData);
                        DataError := true;
                    end
                    else
                    begin
                        PData^.Flags := dde_release;
                        PData^.CFFormat := cf_text;
                        strlcopy(PData^.Value, szWorkingDir,
                                strlen(szWorkingDir)+1);
                        GlobalUnlock(HData)
                    end;
                end;
                if not PostMessage(Msg.WParam, wm_DDE_Data, hwindow,
                                            makelong(HData,AppTopic)) then
                    GlobalFree(HData);
            end
            else
                if stricomp(szTopic,'GetIcon') = 0 then
                begin
                    Msg.lParamLo := GetIconData(extracticon(hinstance,
                                        szIconFile,wIconNumber) );
                  pdata := GlobalLock(Msg.lParamLo);
                  with pdata^ do
                  begin
                        Flags := fRelease;
                        cfFormat := CF_TEXT;
                  end;
                  GlobalUnlock(Msg.lParamLo);
                    SendMessage(Msg.wParam, WM_DDE_DATA, hWindow, Msg.lParam);
                  GlobalFree(Msg.lParamLo);

                end;
    end
    else
        defwndproc(msg);
end;

destructor TOneTimeWindow.Done;
begin
    WritePrivateProfileString(               {unprotect the app by }
        Protected,szAppFileName,    {removing name from INI file}
        nil,szIniPath);
    WritePrivateProfileString(               {and by removing the app}
        szAppFileName,nil,           {section name from INI file}
        nil,szIniPath);
    TWindow.Done;
end;       {TOneTimeWindow.Done;}

function TOneTimeWindow.GetClassName; {give the app unique class name}
var
    paramstring : string;
   sztemp : pchar;
begin
    GetClassName := 'One Time';
end;       {TOneTimeWindow.GetClassName}

var
    app: OneTimeApp;
begin
    app.init('One Time');          {normal Windows object Pascal code}
    app.run;
   app.done;
end.       {ONETIME.PAS}